Dr. Windows 3/dr win3.zip/dr win3/UTILITY1/MSWLGO35.ZIP/EXAMPLES/DOCSETUP

Text File | 1993-04-12 | 23KB | 723 lines

;
; Function:
;
; Simulated Intelligent Doctor
;
; To run:
;
; Load "doctor
; Call SETUP
; Call DOCTOR
;
TO MATCH!
IF EMPTYP :SEN [OP "FALSE]
IF NOT TRY.PRED [OP "FALSE]
MAKE :SPECIAL.VAR FIRST :SEN
OP MATCH BF :PAT BF :SEN
END

TO MATCH#
MAKE :SPECIAL.VAR []
OP #TEST #GATHER :SEN
END

TO #GATHER :SEN
IF EMPTYP :SEN [OP :SEN]
IF NOT TRY.PRED [OP :SEN]
MAKE :SPECIAL.VAR LPUT FIRST :SEN THING :SPECIAL.VAR
OP #GATHER BF :SEN
END

TO #TEST :SEN
IF MATCH BF :PAT :SEN [OP "TRUE]
IF EMPTYP THING :SPECIAL.VAR [OP "FALSE]
OP #TEST2 FPUT LAST THING :SPECIAL.VAR :SEN
END

TO #TEST2 :SEN
MAKE :SPECIAL.VAR BL THING :SPECIAL.VAR
OP #TEST :SEN
END

TO MATCH&
OP &TEST MATCH#
END

TO &TEST :TF
IF EMPTYP THING :SPECIAL.VAR [OP "FALSE]
OP :TF
END

TO MATCH?
MAKE :SPECIAL.VAR []
IF EMPTYP :SEN [OP MATCH BF :PAT :SEN]
IF NOT TRY.PRED [OP MATCH BF :PAT :SEN]
MAKE :SPECIAL.VAR FIRST :SEN
IF MATCH BF :PAT BF :SEN [OP "TRUE]
MAKE :SPECIAL.VAR []
OP MATCH BF :PAT :SEN
END

TO MATCH@
MAKE :SPECIAL.VAR :SEN
OP @TEST []
END

TO @TEST :SEN
IF @TRY.PRED [IF MATCH BF :PAT :SEN [OP "TRUE]]
IF EMPTYP THING :SPECIAL.VAR [OP "FALSE]
OP @TEST2 FPUT LAST THING :SPECIAL.VAR :SEN
END

TO @TEST2 :SEN
MAKE :SPECIAL.VAR BL THING :SPECIAL.VAR
OP @TEST :SEN
END

TO @TRY.PRED
IF LISTP :SPECIAL.PRED [OP MATCH :SPECIAL.PRED THING :SPECIAL.VAR]
OP RUN LIST :SPECIAL.PRED THING :SPECIAL.VAR
END

TO ADDMEMR :WORD :PATTERN :RESULTS
LOCAL "PROPNAME
MAKE "PROPNAME GENSYM
PPROP :WORD "MEMR ( SE GPROP :WORD "MEMR LIST :PATTERN :PROPNAME )
PPROP :WORD :PROPNAME :RESULTS
END

TO ADDPUNCT :STUFF :CHAR
IF WORDP :STUFF [OUTPUT WORD :STUFF :CHAR]
IF EMPTYP :STUFF [OUTPUT :CHAR]
OUTPUT SE BL :STUFF WORD LAST :STUFF :CHAR
END

TO ADDRULE :WORD :PATTERN :RESULTS
LOCAL "PROPNAME
MAKE "PROPNAME GENSYM
PPROP :WORD "RULES ( SE GPROP :WORD "RULES LIST :PATTERN :PROPNAME )
PPROP :WORD :PROPNAME :RESULTS
END

TO ALWAYS :X
OP "TRUE
END

TO ANALYZE :SENTENCE :KEYWORDS
LOCAL [RULES KEYWORD]
IF EMPTYP :KEYWORDS [NORULES STOP]
MAKE "KEYWORD FIRST :KEYWORDS
MAKE "RULES GPROP :KEYWORD "RULES
IF WORDP FIRST :RULES ~
   [MAKE "KEYWORD FIRST :RULES MAKE "RULES GPROP :KEYWORD "RULES]
CHECKRULES :KEYWORD :RULES
END

TO ANYOF :SEN
OP ANYOF1 :SEN :IN.LIST
END

TO ANYOF1 :SEN :PATS
IF EMPTYP :PATS [OP "FALSE]
IF MATCH FIRST :PATS :SEN [OP "TRUE]
OP ANYOF1 :SEN BF :PATS
END

TO BELIEFP :WORD
OUTPUT NOT EMPTYP GPROP :WORD "BELIEF
END

TO CHECKPRIORITY :WORD
LOCAL "PRIORITY
MAKE "PRIORITY GPROP :WORD "PRIORITY
IF EMPTYP :PRIORITY [STOP]
IF EMPTYP :KEYWORDS [MAKE "KEYWORDS ( LIST :WORD ) STOP]
IFELSE :PRIORITY > ( GPROP FIRST :KEYWORDS "PRIORITY ) ~
       [MAKE "KEYWORDS FPUT :WORD :KEYWORDS] ~
       [MAKE "KEYWORDS LPUT :WORD :KEYWORDS]
END

TO CHECKRULES :KEYWORD :RULES
IF NOT MATCH FIRST :RULES :SENTENCE ~
   [CHECKRULES :KEYWORD BF BF :RULES STOP]
DORULE FIRST BF :RULES
END

TO DOCTOR
LOCAL [TEXT SENTENCE STUFF A B C RULES KEYWORDS]
MAKE "MEMORY []
PR [HELLO, I AM THE DOCTOR. WHAT CAN I DO FOR YOU?]
PR [PLEASE END YOUR REMARKS WITH AN EMPTY LINE.]
PR []
LOOP
END

TO DORULE :RULE
LOCAL "PRINT
MAKE "PRINT FIRST GPROP :KEYWORD :RULE
PPROP :KEYWORD :RULE LPUT :PRINT BF GPROP :KEYWORD :RULE
IF EQUALP :PRINT "NEWKEY [ANALYZE :SENTENCE BF :KEYWORDS STOP]
IF WORDP :PRINT [CHECKRULES :PRINT GPROP :PRINT "RULES STOP]
IF EQUALP FIRST :PRINT "PRE ~
   [ANALYZE RECONSTRUCT FIRST BF :PRINT BF BF :PRINT STOP]
PRINT RECONSTRUCT :PRINT
MEMORY :KEYWORD :SENTENCE
END

TO FAMILYP :WORD
OUTPUT NOT EMPTYP GPROP :WORD "FAMILY
END

TO GETSENTENCE :TEXT
MAKE "KEYWORDS []
OUTPUT GETSENTENCE1 :TEXT []
END

TO GETSENTENCE1 :TEXT :OUT
IF EMPTYP :TEXT [OUTPUT :OUT]
IF EQUALP FIRST :TEXT ". ~
   [IFELSE EMPTYP :KEYWORDS ~
           [OUTPUT GETSENTENCE1 BF :TEXT []] [OUTPUT :OUT]]
CHECKPRIORITY FIRST :TEXT
OUTPUT GETSENTENCE1 BF :TEXT SE :OUT TRANSLATE FIRST :TEXT
END

TO GETSTUFF :STUFF
LOCAL "LINE
MAKE "LINE RL
IF EMPTYP :LINE [OP :STUFF]
OP GETSTUFF SE :STUFF :LINE
END

TO IN :WORD
OP MEMBERP :WORD :IN.LIST
END

TO LASTRESORT
PRINT FIRST :LASTRESORT
MAKE "LASTRESORT LPUT FIRST :LASTRESORT BF :LASTRESORT
END

TO LOOP
MAKE "TEXT TOKENIZE GETSTUFF []
MAKE "SENTENCE GETSENTENCE :TEXT
ANALYZE :SENTENCE :KEYWORDS
PRINT []
LOOP
END

TO MATCH :PAT :SEN
LOCAL [SPECIAL.VAR SPECIAL.PRED SPECIAL.BUFFER IN.LIST]
IF OR WORDP :PAT WORDP :SEN [OP "FALSE]
IF EMPTYP :PAT [OP EMPTYP :SEN]
IF LISTP FIRST :PAT [OP SPECIAL FPUT "!: :PAT :SEN]
IF MEMBERP FIRST FIRST :PAT [? # ! & @] [OP SPECIAL :PAT :SEN]
IF EMPTYP :SEN [OP "FALSE]
IF EQUALP FIRST :PAT FIRST :SEN [OP MATCH BF :PAT BF :SEN]
OP "FALSE
END

TO MEMORY :KEYWORD :SENTENCE
LOCAL [RULES RULE NAME]
MAKE "RULES GPROP :KEYWORD "MEMR
IF EMPTYP :RULES [STOP]
IF NOT MATCH FIRST :RULES :SENTENCE [STOP]
MAKE "NAME LAST :RULES
MAKE "RULES GPROP :KEYWORD :NAME
MAKE "RULE FIRST :RULES
PPROP :KEYWORD :NAME LPUT :RULE BF :RULES
MAKE "MEMORY FPUT RECONSTRUCT :SENTENCE :MEMORY
END

TO NORULES
IFELSE :MEMFLAG [USEMEMORY] [LASTRESORT]
MAKE "MEMFLAG NOT :MEMFLAG
END

TO PARSE.SPECIAL :WORD :VAR
IF EMPTYP :WORD [OP LIST :VAR "ALWAYS]
IF EQUALP FIRST :WORD ": [OP LIST :VAR BF :WORD]
OP PARSE.SPECIAL BF :WORD WORD :VAR FIRST :WORD
END

TO QUOTED :THING
IF LISTP :THING [OP :THING]
OP WORD "" :THING
END

TO RECONSTRUCT :SENTENCE
IF EMPTYP :SENTENCE [OUTPUT []]
IF NOT EQUALP ": FIRST FIRST :SENTENCE ~
   [OUTPUT FPUT FIRST :SENTENCE RECONSTRUCT BF :SENTENCE]
OUTPUT SE REWORD FIRST :SENTENCE RECONSTRUCT BF :SENTENCE
END

TO REWORD :WORD
IF MEMBERP LAST :WORD [. ? ,] [OUTPUT ADDPUNCT REWORD BL :WORD LAST :WORD]
OUTPUT THING BF :WORD
END

TO SET.IN
MAKE "IN.LIST FIRST BF :PAT
MAKE "PAT FPUT FIRST :PAT BF BF :PAT
END

TO SET.SPECIAL :LIST
MAKE "SPECIAL.VAR FIRST :LIST
MAKE "SPECIAL.PRED LAST :LIST
IF EMPTYP :SPECIAL.VAR [MAKE "SPECIAL.VAR "SPECIAL.BUFFER]
IF MEMBERP :SPECIAL.PRED [IN ANYOF] [SET.IN]
IF NOT EMPTYP :SPECIAL.PRED [STOP]
MAKE "SPECIAL.PRED FIRST BF :PAT
MAKE "PAT FPUT FIRST :PAT BF BF :PAT
END

TO SETUP
MAKE "MEMFLAG "FALSE
MAKE "LASTRESORT [[I AM NOT SURE I UNDERSTAND YOU FULLY.] ~
  [PLEASE GO ON.] ~
  [WHAT DOES THAT SUGGEST TO YOU?] ~
  [DO YOU FEEL STRONGLY ABOUT DISCUSSING SUCH THINGS?]]
SETUP1
SETUP2
SETUP3
SETUP4
ERASE [SETUP1 SETUP2 SETUP3 SETUP4 ADDRULE ADDMEMR SETUP]
END

TO SETUP1
PPROP "SORRY "PRIORITY 0
ADDRULE "SORRY [#] ~
  [[PLEASE DON'T APOLOGIZE.] ~
   [APOLOGIES ARE NOT NECESSARY.] ~
   [WHAT FEELINGS DO YOU HAVE WHEN YOU APOLOGIZE?] ~
   [I'VE TOLD YOU THAT APOLOGIES ARE NOT REQUIRED.]]
PPROP "DONT "TRANSLATION "DON'T
PPROP "CANT "TRANSLATION "CAN'T
PPROP "WONT "TRANSLATION "WON'T
PPROP "REMEMBER "PRIORITY 5
ADDRULE "REMEMBER ~
  [# YOU REMEMBER #STUFF] ~
  [[DO YOU OFTEN THINK OF :STUFF?] ~
   [DOES THINKING OF :STUFF BRING ANYTHING ELSE TO MIND?] ~
   [WHAT ELSE DO YOU REMEMBER?] ~
   [WHY DO YOU REMEMBER :STUFF JUST NOW?] ~
   [WHAT IN THE PRESENT SITUATION REMINDS YOU OF :STUFF?]]
ADDRULE "REMEMBER [# DO I REMEMBER #STUFF] ~
  [[DID YOU THINK I WOULD FORGET :STUFF?] ~
   [WHY DO YOU THINK I SHOULD RECALL :STUFF NOW?] ~
   [WHAT ABOUT :STUFF?] WHAT [YOU MENTIONED :STUFF.]]
ADDRULE "REMEMBER [#] [NEWKEY]
PPROP "IF "PRIORITY 3
ADDRULE "IF [#A IF #B HAD #C] [[PRE [:A IF :B MIGHT HAVE :C] IF]]
ADDRULE "IF [# IF #STUFF] ~
  [[DO YOU THINK IT'S LIKELY THAT :STUFF?] ~
   [DO YOU WISH THAT :STUFF?] ~
   [WHAT DO YOU THINK ABOUT :STUFF?]]
PPROP "DREAMED "PRIORITY 4
ADDRULE "DREAMED [# YOU DREAMED #STUFF] ~
  [[REALLY :STUFF?] ~
   [HAVE YOU EVER FANTASIED :STUFF WHILE YOU WERE AWAKE?] ~
   [HAVE YOU DREAMED :STUFF BEFORE?] DREAM NEWKEY]
ADDRULE "DREAMED [#] [DREAM NEWKEY]
PPROP "DREAMT "TRANSLATION "DREAMED
PPROP "DREAMT "PRIORITY 4
PPROP "DREAMT "RULES [DREAMED]
PPROP "DREAM "PRIORITY 3
ADDRULE "DREAM [#] ~
  [[WHAT DOES THAT DREAM SUGGEST TO YOU?] ~
   [DO YOU DREAM OFTEN?] ~
   [WHAT PERSONS APPEAR IN YOUR DREAMS?] ~
   [DON'T YOU BELIEVE THAT DREAM HAS SOMETHING TO DO WITH YOUR PROBLE